unit RepPrint;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,frxClass, frxDesgn,frxDBSet,frxBarcode, frxRich, frxChBox,DBClient,
  VarUtils,DB,frxPrinter, frxPreview;

type
  TRepPrint = class;

  TFormPreview = class(TForm)
  private
    { Private declarations }
  public
    { Public declarations }
  end;

  TPrnClientDataSet = class(TClientDataSet)
  protected
    procedure DoAfterOpen; override;
  end;

  TfrxPrnDataSet = class(TfrxDBDataset)
  private
    FClientDataSet: TPrnClientDataSet;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

  TDataSetList = class(TList)
  private
    FOwner: TComponent;
    FDataSetClass: TComponentClass;
    function GetMasterDataSet: TComponent;
    function GetDetailDataSet: TComponent;
  protected
    function Get(Index: Integer): TComponent;
    procedure Put(Index: Integer; Item: TComponent);
    procedure Notify(Ptr: Pointer; Action: TListNotification); override;
    function GetClientDataSets(Index: Integer): TPrnClientDataSet;
    procedure AddMasterDetailDataSet;
  public
    constructor Create(AOwner: TComponent; ADataSetClass: TComponentClass);
    function IndexOf(ADataSetName: String): Integer; overload;
    function Add: Integer;
    property Items[Index: Integer]: TComponent read Get write Put; default;
    property ClientDataSets[Index: Integer]: TPrnClientDataSet read GetClientDataSets;
    property Owner: TComponent read FOwner;
    property DataSetClass: TComponentClass read FDataSetClass;
    property MasterDataSet: TComponent read GetMasterDataSet;
    property DetailDataSet: TComponent read GetDetailDataSet;
  end;

  TRepPrint = class(TComponent)
  private
    FFr3Form : TFormPreview;
    FFrReport3: TfrxReport;
    FPrepared: Boolean;
    FDataSetList: TDataSetList;
    FValueList: TPrnClientDataSet;
    FClearLastReport: Boolean;
    FPrinterIndex: Integer;
    FShowSetupDialog: Boolean;
    function GetBlobValues(const Index: WideString): OleVariant;
    function GetStrValues(const Index: WideString): WideString;
    procedure SetBlobValues(const Index: WideString;Value: OleVariant);
    procedure SetStrValues(const Index, Value: WideString);
    function GetValueList: TPrnClientDataSet;
    procedure CreateValueListDataSet;

    function GetFrReport3: TfrxReport;
    function GetFr3Form: TFormPreview;
    function GetDataSetList: TDataSetList;

    procedure DrawImageToPictureView3(pPictureView: TfrxPictureView; pBitMap: TBitMap);
    function PrepareFastReport3: Boolean;
    procedure PrintFastReport3(Copies: Integer = 1; bPreview: Boolean = False);
    procedure ClearValues;
    function SetDataSetData(ADataSetName: OleVariant; AData: OleVariant; Index: Integer = -1): Boolean;

    property FrReport3: TfrxReport read GetFrReport3;
    property Fr3Form: TFormPreview read GetFr3Form;
    property DataSetList: TDataSetList read GetDataSetList;
    property ValueList: TPrnClientDataSet read GetValueList;
    property ClearLastReport: Boolean read FClearLastReport write FClearLastReport;
    property Prepared: Boolean read FPrepared write FPrepared;
  public
    constructor Create(AOwner: TComponent);override;
    destructor Destroy; override;
    procedure Initialize;
    procedure Print(Copies: Integer);
    procedure Preview;
    function DesignRep(var RepData: OleVariant): WordBool;
    procedure GetRepFormat(RepData: OleVariant);

    function SetMasterDataSet(AData: OleVariant): WordBool;
    function SetDetailDataSet(AData: OleVariant): WordBool;
    function SetXMListDataSet(AData: OleVariant): WordBool;
    procedure LoadFromStream(StreamData: OleVariant);

    property Values[const Index: WideString]: WideString read GetStrValues write SetStrValues;
    property BlobValues[const Index: WideString]: OleVariant read GetBlobValues write SetBlobValues;
    property PrinterIndex:Integer read FPrinterIndex write FPrinterIndex;
    property ShowSetupDialog: Boolean read FShowSetupDialog write FShowSetupDialog;
  end;

  
var
  FormPreview: TFormPreview;

implementation

{$R *.dfm}

function StreamToByteArray(var Dest: TVarData; Stream: TMemoryStream;
                           AStartPos: DWord = 0; ACount: Integer = 0): HRESULT;
var
  P: Pointer;
  LArray: PVarArray;
  LData: Pointer;
  LCount: Integer;
  LVarBounds: Array[0..0] Of TVarArrayBound;
begin
  Result := VAR_OK;
  if AStartPos = 0 then LCount := Stream.Size
    else LCount := ACount;
  LVarBounds[0].LowBound := 0;
  LVarBounds[0].ElementCount := LCount;
  LArray := SafeArrayCreate(varByte, 1, PVarArrayBoundArray(@LVarBounds)^);
  Try
    Result := SafeArrayLock(LArray);
    if Result = VAR_OK then
    Try
      Result := SafeArrayAccessData(LArray, LData);
      if Result = VAR_OK then
      Try
        P := Pointer(DWord(Stream.Memory) + AStartPos); 
        Move(P^, LData^, LCount)
      Finally
        Result := SafeArrayUnaccessData(LArray);
      End;
    Finally
      if Result = VAR_OK then
        Result := SafeArrayUnlock(LArray)
      else
        SafeArrayUnlock(LArray);
    End;
  Finally
    if Result <> VAR_OK then
      SafeArrayDestroy(LArray)
    else begin
      Dest.VType := varArray + varByte;
      Dest.VArray := LArray;
    end;
  End;
end;

function ByteArrayToStream(var Dest: TVarData; Stream: TMemoryStream;
                           AStartPos: DWord = 0): HRESULT;
var
  P: Pointer;
  LArray: PVarArray;
  LData: Pointer;
  LCount: DWord;
begin
  LArray := Dest.VArray;
  Result := SafeArrayLock(LArray);
  if Result = VAR_OK then
  Try
    Result := SafeArrayAccessData(LArray, LData);
    if Result = VAR_OK then
    Try
      LCount := LArray.Bounds[0].ElementCount;
      if AStartPos = 0 then
        Stream.Size := LCount
      else if AStartPos + LCount > Stream.Size then
        Stream.Size := AStartPos + LCount;
      P := Pointer(DWord(Stream.Memory) + AStartPos);
      Move(LData^, P^, LCount);
    Finally
      Result := SafeArrayUnaccessData(LArray);
    End;
  Finally
    if Result = VAR_OK then
      Result := SafeArrayUnlock(LArray)
    else
      SafeArrayUnlock(LArray);
  End;
end;

{ TPrnClientDataSet }

procedure TPrnClientDataSet.DoAfterOpen;
begin
  inherited DoAfterOpen;
  LogChanges := False;

end;


{ TfrxPrnDataSet }

constructor TfrxPrnDataSet.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FClientDataSet := TPrnClientDataSet.Create(AOwner);
  DataSet := FClientDataSet;

end;

destructor TfrxPrnDataSet.Destroy;
begin
  DataSet := Nil;
  FClientDataSet.Free;
  inherited Destroy;
end;


{ TDataSetList }

function TDataSetList.Add: Integer;
begin
  Result := inherited Add(FDataSetClass.Create(Owner));
end;

procedure TDataSetList.AddMasterDetailDataSet;
begin
  Add; //Index = 0 Master
  Add; //Index = 1 Detail

end;

constructor TDataSetList.Create(AOwner: TComponent;
  ADataSetClass: TComponentClass);
begin
  inherited Create;
  FOwner := AOwner;
  FDataSetClass := ADataSetClass;
  AddMasterDetailDataSet;

end;

function TDataSetList.Get(Index: Integer): TComponent;
begin
  Result := TComponent(inherited Get(Index));
end;

function TDataSetList.GetClientDataSets(Index: Integer): TPrnClientDataSet;
begin
  if SameText(DataSetClass.ClassName, TfrxPrnDataSet.ClassName) then
    Result := TPrnClientDataSet(TfrxPrnDataSet(Items[Index]).DataSet)
  else
    Result := Nil;

end;

function TDataSetList.GetDetailDataSet: TComponent;
begin
  Result := Items[1];
end;

function TDataSetList.GetMasterDataSet: TComponent;
begin
  Result := Items[0];
end;

function TDataSetList.IndexOf(ADataSetName: String): Integer;
var
  i: Integer;
  sName: String;
begin
  Result := -1;
  For i := 0 To Count - 1 Do
  begin
    sName := ClientDataSets[i].Name;
    if AnsiCompareText(ADataSetName, sName) = 0 then
    begin
      Result := i;
      Break;
    end;
  end;

end;

procedure TDataSetList.Notify(Ptr: Pointer; Action: TListNotification);
begin
  if (Action = lnDeleted) and Assigned(Ptr) then
  begin
    TComponent(Ptr).Free;
  end;

end;

procedure TDataSetList.Put(Index: Integer; Item: TComponent);
begin
  inherited Put(Index, Item);
end;

{ TRepPrint }

constructor TRepPrint.Create(AOwner: TComponent);
begin
  frxCharset := GB2312_CHARSET;
  inherited Create(AOwner);
  Initialize;

end;

destructor TRepPrint.Destroy;
begin
  Prepared := False;
  if Assigned(FDataSetList) then
  begin
    FDataSetList.Free;
    FDataSetList := Nil;
  end;
  if Assigned(FFr3Form) then
  begin
    FFr3Form.Free;
    FFr3Form := Nil;
  end;
  inherited Destroy;
end;

procedure TRepPrint.Initialize;
begin
  FPrepared := False;
  FClearLastReport := True;
  FPrinterIndex := -1;
  FShowSetupDialog := False;
end;

function TRepPrint.GetFr3Form: TFormPreview;
begin
  if Not Assigned(FFr3Form) then
    FFr3Form := TFormPreview.Create(Self);
  Result := FFr3Form;

end;

function TRepPrint.GetFrReport3: TfrxReport;
begin
  if Not Assigned(FFrReport3) then
    FFrReport3 := TfrxReport.Create(Fr3Form);
  Result := FFrReport3;
end;

procedure TRepPrint.Print(Copies: Integer);
begin
  PrintFastReport3(Copies);
end;

procedure TRepPrint.DrawImageToPictureView3(pPictureView: TfrxPictureView;
  pBitMap: TBitMap);
Const
  PictureSize: Array[TfrxPrintType] Of Integer = (0, 3, 2, 1);
var
  B: TBitMap;
  px, py: Integer;
  kx, ky: Double;
  R, RRest, DRect: TRect;
begin
  With pPictureView Do
  begin
    Stretched := (PrintType <> frxClass.pt1Size);
    if PrintType = frxClass.ptPicture then
    begin
      Picture.Bitmap.Assign(pBitMap);
    end
    else
    begin
      px := DX * PictureSize[PrintType];
      py := DY * PictureSize[PrintType];
      DRect := Rect(0, 0, px, py);
      kx := px / pBitMap.Width;
      ky := py / pBitMap.Height;
      if kx < ky then
      begin
        R := Rect(DRect.Left, DRect.Top, DRect.Right, DRect.Top + Trunc(pBitMap.Height * kx));
        RRest := Rect(DRect.Left, R.Bottom, DRect.Right, DRect.Bottom);
      end
      else
      begin
        R := Rect(DRect.Left, DRect.Top, DRect.Left + Trunc(pBitMap.Width * ky), DRect.Bottom);
        RRest := Rect(R.Right, DRect.Top, DRect.Right, DRect.Bottom);
      end;
      B := TBitMap.Create;
      Try
        if PrintType <> frxClass.ptPicture then
        begin
          B.Width := R.Right - R.Left;
          B.Height:= R.Bottom - R.Top;
          B.PixelFormat := pBitMap.PixelFormat;
          B.Canvas.StretchDraw(R, pBitMap);
          B.Canvas.Brush.Color := clWhite;
          B.Canvas.FillRect(RRest);
          B.Canvas.FrameRect(RRest);
        end
        else
        begin
          B.Width := px;
          B.Height:= py;
          B.PixelFormat := pBitMap.PixelFormat;
          B.Canvas.StretchDraw(R, pBitMap);
          B.Canvas.Brush.Color := clWhite;
          B.Canvas.FillRect(RRest);
          B.Canvas.FrameRect(RRest);
        end;
        pPictureView.Picture.Bitmap.Assign(B);
      Finally
        B.Free;
      End;
    end;
  end;

end;


function TRepPrint.PrepareFastReport3: Boolean;
var
  i,j,iIndex : Integer;
  sPName,sXMVal : string;
  B: TBitMap;
  V: OleVariant;
  M: TMemoryStream;
  oAllObjects: TList;
begin
  Result := False;
  With FrReport3, DataSetList Do
  begin
    Try
      DataSets.Clear;
      For i := 0 To Count - 1 Do
      begin
        DataSets.Add(TfrxPrnDataSet(Items[i]));
      end;

      for i := 0 to PagesCount - 1 do
      begin
        with Pages[i] do
        begin
          oAllObjects := AllObjects;
          for j := 0 to AllObjects.Count -1 do
          begin
            sPName := TfrxReportComponent(oAllObjects[j]).HisName;

            if Pos('RPTM_', sPName) = 1 then
            begin
              System.Delete(sPName, 1, 5);
              TfrxMemoView(oAllObjects[j]).Memo.Text :=
                           Format('[%S."%S"]', [TfrxPrnDataSet(MasterDataSet).DataSet.Name, sPName]);
            //  TfrxMemoView(AllObjects[j]).DataSet := TfrxPrnDataSet(MasterDataSet);
            //  TfrxMemoView(AllObjects[j]).DataField := sPName;
            end
            else if pos('RPTD_', sPName) = 1 then
            begin
              System.Delete(sPName, 1, 5);
              TfrxMemoView(oAllObjects[j]).Memo.Text :=
                           Format('[%S."%S"]', [TfrxPrnDataSet(DetailDataSet).DataSet.Name, sPName]);
            end
            else if Length(sPName) > 0 then
            begin
            //  if TObject(oAllObjects[j]) is TfrxMasterData then    TfrxDataBand
              if TObject(oAllObjects[j]) is TfrxDataBand then
              begin
                iIndex := IndexOf(sPName);
                if iIndex >= 0 then
                begin
                  //TfrxMasterData(oAllObjects[j]).DataSet := TfrxPrnDataSet(Items[iIndex]);
                  TfrxDataBand(oAllObjects[j]).DataSet := TfrxPrnDataSet(Items[iIndex]);
                end;
              end
              else if TfrxView(oAllObjects[j]) is TfrxPictureView then
              begin
                B := TBitMap.Create;
                M := TMemoryStream.Create;
                Try
                  V := BlobValues[sPName];
                  ByteArrayToStream(TVarData(V), M);
                  if M.Size > 0 then
                  begin
                    B.LoadFromStream(M);
                    DrawImageToPictureView3(TfrxPictureView(oAllObjects[j]), B);
                  end
                  else begin
                    TfrxPictureView(oAllObjects[j]).Picture.Bitmap := Nil;
                  end;
                Finally
                  B.Free;
                  M.Free;
                End;
              end
              else
              begin
                sXMVal := Values[sPName];
                if TfrxView(oAllObjects[j]) is TfrxMemoView then
                  TfrxMemoView(oAllObjects[j]).Memo.Text := sXMVal
                else if TfrxView(oAllObjects[j]) is TfrxBarCodeView then
                  TfrxBarCodeView(oAllObjects[j]).Text := sXMVal
                else if TfrxView(oAllObjects[j]) is TfrxRichView then
                  TfrxRichView(oAllObjects[j]).RichEdit.Text := sXMVal
                else if TfrxView(oAllObjects[j]) is TfrxCheckBoxView then
                  TfrxCheckBoxView(oAllObjects[j]).Checked := (sXMVal <> '')
                else if TfrxView(oAllObjects[j]) is TfrxShapeView then
                  TfrxShapeView(oAllObjects[j]).Visible := (sXMVal <> '');
              end;
            end;
          end;
        end;
      end;
      ShowProgress := True;
      Result := PrepareReport(ClearLastReport);
    Except
      On E: Exception Do
      begin
        Raise Exception.Create(E.Message);
      end;
    End;
  end;

end;

procedure TRepPrint.PrintFastReport3(Copies: Integer; bPreview: Boolean);
var
  iPrinter: Integer;
begin
  With FrReport3 Do
  begin
    if Not Prepared then
      Prepared := PrepareFastReport3;
    if Prepared then
    begin
      iPrinter := frxPrinters.PrinterIndex;
      Try
        Try
          if PrinterIndex <> -1 then
          begin
            frxPrinters.PrinterIndex := PrinterIndex;
          end;
          Preview := Nil;
          if bPreview then
          begin
          {  if Assigned(APreviewForm) then
            begin
              Preview := TfrxPreview(APreviewForm.PreviewControl);
            end;
            }
            ShowPreparedReport;
          end
          else
          begin
            PrintOptions.ShowDialog := FShowSetupDialog;
            PrintOptions.Copies := Copies;
            PrintOptions.Collate := True;
            PrintOptions.PageNumbers:= Format('1-%D', [PreviewPages.Count]);
            PrintOptions.PrintPages := ppAll;
            Print;
          end;
        Except
          On E: Exception Do
          begin
            Raise Exception.Create(E.Message);
          end;
        End;
      Finally
        frxPrinters.PrinterIndex := iPrinter;
      End;
    end;
    
  end;

end;

function TRepPrint.GetDataSetList: TDataSetList;
begin
  if Not Assigned(FDataSetList) then
    FDataSetList := TDataSetList.Create(Fr3Form, TfrxPrnDataSet);
  Result := FDataSetList;

end;

function TRepPrint.GetBlobValues(const Index: WideString): OleVariant;
var
  M: TMemoryStream;
begin
  With ValueList Do
  begin
    if Locate('Name', Index, [loCaseInsensitive	]) and
       (FieldByName('Flag').AsInteger = 2) then
    begin
      M := TMemoryStream.Create;
      Try
        TBlobField(FieldByName('BlobValue')).SaveToStream(M);
        StreamToByteArray(TVarData(Result), M);
      Finally
        M.Free;
      End;
    end
    else begin
      Result := Null;
    end;
  end;

end;

function TRepPrint.GetStrValues(const Index: WideString): WideString;
begin
  With ValueList Do
  begin
    if Locate('Name', Index, [loCaseInsensitive	]) and
       (FieldByName('Flag').AsInteger in [0,1]) then
    begin
      if FieldByName('Flag').AsInteger = 0 then
        Result := FieldByName('StrValue').AsString
      else
        Result := FieldByName('BlobValue').AsString;
    end
    else begin
      Result := '';
    end;
  end;

end;

procedure TRepPrint.SetBlobValues(const Index: WideString; Value: OleVariant);
var
  M: TMemoryStream;
  sName: String;
begin
  With ValueList Do
  begin
    sName := Index;
    if Locate('Name', sName, []) then
    begin
      Edit;
    end
    else
    begin
      Append;
      FieldByName('Name').AsString := sName;
    end;
    FieldByName('StrValue').Clear;
    M := TMemoryStream.Create;
    Try
      ByteArrayToStream(TVarData(Value), M);
      TBlobField(FieldByName('BlobValue')).LoadFromStream(M);
      FieldByName('Flag').AsInteger := 2;
      Post;
    Finally
      M.Free;
    End;
  end;

end;

procedure TRepPrint.SetStrValues(const Index, Value: WideString);
var
  sName, sValue: String;
begin
  With ValueList Do
  begin
    sName := Index;
    sValue := Value;
    if Locate('Name', sName, []) then
    begin
      Edit;
    end
    else
    begin
      Append;
      FieldByName('Name').AsString := sName;
    end;
    if Length(sValue) < FieldByName('StrValue').Size then
    begin
      FieldByName('BlobValue').Clear;
      FieldByName('StrValue').AsString := sValue;
      FieldByName('Flag').AsInteger := 0;
    end
    else begin
      FieldByName('StrValue').Clear;
      FieldByName('BlobValue').AsString := sValue;
      FieldByName('Flag').AsInteger := 1;
    end;
    Post;
  end;

end;

function TRepPrint.GetValueList: TPrnClientDataSet;
begin
  if Not Assigned(FValueList) then
  begin
    CreateValueListDataSet;
  end;
  Result := FValueList;
end;

procedure TRepPrint.CreateValueListDataSet;
begin
  FValueList := TPrnClientDataSet.Create(Nil);
  With FValueList Do
  begin
    FieldDefs.Clear;
    FieldDefs.Add('Name', ftString, 20, True);
    FieldDefs.Add('StrValue', ftString, 100, False);
    FieldDefs.Add('BlobValue', ftBlob, 0, False);
    FieldDefs.Add('Flag', ftSmallint, 0, True);
    CreateDataSet;
    IndexFieldNames := 'Name';
  end;

end;

procedure TRepPrint.ClearValues;
begin
  Prepared := False;
  if Assigned(FValueList) then
  begin
    ValueList.EmptyDataSet;
  end;
  if Assigned(FDataSetList) then
  begin
    DataSetList.Clear;
    DataSetList.AddMasterDetailDataSet;
  end;
end;

procedure TRepPrint.Preview;
begin
  PrintFastReport3(1,True);
end;

function TRepPrint.DesignRep(var RepData: OleVariant): WordBool;
var
  M: TMemoryStream;
  vFileName: String;
begin
  Result := False;
  M := TMemoryStream.Create;
  Try
    With FrReport3 Do
    begin
      EditField := M;
      DesignReport;
      Result := (M.Size > 0);
    end;
    if Result then
      StreamToByteArray(TVarData(RepData), M);

  Finally
    M.Free;
  End;

end;

function TRepPrint.SetDetailDataSet(AData: OleVariant): WordBool;
begin
  Result := SetDataSetData('DDataSet', AData, 1);
end;

function TRepPrint.SetMasterDataSet(AData: OleVariant): WordBool;
begin
  Result := SetDataSetData('MDataSet', AData, 0);
end;

function TRepPrint.SetXMListDataSet(AData: OleVariant): WordBool;
begin
  Result := SetDataSetData('XMDataSet', AData, 2);
end;

function TRepPrint.SetDataSetData(ADataSetName, AData: OleVariant;
  Index: Integer): Boolean;
begin
  With DataSetList Do
  begin
    Result := True;
    Try
      if Index = -1 then
        Index := IndexOf(ADataSetName);
      if Index = -1 then
        Index := Add;
      Items[Index].Name := Format('RPTDataSet%D', [Index]);
      if Items[Index] is TfrxPrnDataSet then
      begin
        TfrxPrnDataSet(Items[Index]).UserName := ADataSetName;
      end;
      ClientDataSets[Index].Name := ADataSetName;
      ClientDataSets[Index].Data := AData;
    Except
      Result := False;
    End;
  end;

end;

procedure TRepPrint.LoadFromStream(StreamData: OleVariant);
begin

end;

procedure TRepPrint.GetRepFormat(RepData: OleVariant);
var
  B: Char;
  i: Integer;
  M: TMemoryStream;
begin
  M := TMemoryStream.Create;
  Try
    ByteArrayToStream(TVarData(RepData), M);
    M.Position := 0;
    FrReport3.LoadFromStream(M);
  Finally
    M.Free;
  End;
end;

end.
